home *** CD-ROM | disk | FTP | other *** search
/ Hack-Mag 3 / Hack-Mag - Issue 3 (1991-02-02)(D-Tect)(PD).adf / Sources / TestThisFractalPRG.bas < prev   
BASIC Source File  |  2014-06-19  |  10KB  |  440 lines
  1. REM    >->->  A P F E L M A E N C H E N  <-<-<
  2. REM
  3. REM
  4.  
  5. Parameter:
  6.   INPUT "Zahl der Iterationen: ",Iter
  7.   INPUT "Zahl der Farben (2,4,8,16,32): ",Colors
  8.   
  9.   DIM Betrag(Iter)
  10.  
  11.   a=1
  12.   FOR S=1 TO Colors-1
  13.     PRINT S". Farb-Iter ";
  14.     INPUT b
  15.     FOR f=a TO b
  16.       Betrag(f)=S
  17.     NEXT f
  18.     a=b
  19.   NEXT S
  20.  
  21.   PRINT
  22.   FOR S=1 TO Iter:PRINT Betrag(S):NEXT S
  23.   PRINT
  24.   IF Com=1 THEN GOTO CCont
  25.   INPUT "x-Start: ",xStart
  26.   INPUT "x-End: ",xEnd
  27.   INPUT "y-Start: ",yStart
  28.   INPUT "y-End: ",yEnd
  29.   PRINT
  30.  
  31.  CCont:
  32.   INPUT "Screen-Breite: ",ScrWidth
  33.   INPUT "Screen-Höhe: ",ScrHight
  34.  
  35. Vorbereitungen:
  36.   IF Colors=2 THEN Tiefe=1
  37.   IF Colors=4 THEN Tiefe=2
  38.   IF Colors=8 THEN Tiefe=3
  39.   IF Colors=16 THEN Tiefe=4
  40.   IF Colors=32 THEN Tiefe=5
  41.  
  42.   IF Com=1 THEN WINDOW 3:CLS:GOTO NoNew
  43.  
  44.   SCREEN 2,320,256,5,1    '5!
  45.   WINDOW 3,,,0,2
  46.  
  47.  NoNew:
  48.  
  49.   PALETTE 0,0,0,0
  50.   PALETTE 1,0,0,1/16
  51.   PALETTE 2,0,0,2/16
  52.   PALETTE 3,0,0,3/16
  53.   PALETTE 4,0,0,4/16
  54.   PALETTE 5,0,0,5/16
  55.   PALETTE 6,0,0,6/16
  56.   PALETTE 7,0,0,7/16
  57.   PALETTE 8,0,0,8/16
  58.   PALETTE 9,0,0,9/16
  59.   PALETTE 10,0,0,10/16
  60.   PALETTE 11,0,0,11/16
  61.   PALETTE 12,0,0,12/16
  62.   PALETTE 13,0,0,13/16
  63.   PALETTE 14,0,0,14/16
  64.   PALETTE 15,0,0,15/16
  65.  
  66.  
  67.  
  68.   x=0:y=0                      'Variablen fuer Graphic
  69.   zr=0:zi=0                    'Aufteilung der komplexen Zahl z
  70.   cr=xStart:ci=yStart          'Startkoordinaten der Apfel-Menge
  71.  
  72.   xStep=((ABS(xStart)+ABS(xEnd))/ScrWidth)
  73.   yStep=((ABS(yStart)+ABS(yEnd))/ScrHight)
  74.  
  75. Kontrolle:
  76.   WINDOW 1
  77.   PRINT
  78.   PRINT "Iterationen: "Iter,"Farbzahl: "Colors
  79.   PRINT
  80.   PRINT "Beträge: ";
  81.   FOR S=1 TO Iter
  82.     PRINT Betrag(S);
  83.   NEXT S
  84.   PRINT
  85.   PRINT "xStart, xEnd, yStart, yEnd: "xStart" "xEnd" "yStart" "yEnd
  86.   PRINT "Breite, Breite: "ScrWidth" "ScrHight
  87.   PRINT "xStep, yStep: "xStep" "yStep
  88.   WHILE INKEY$="" : WEND
  89.   WINDOW 3
  90. Berechnung:
  91.  
  92.   WHILE y<ScrHight
  93.  
  94.     FOR S=1 TO Iter
  95.  
  96.       sr=zr*zr-zi*zi+cr
  97.       si=2*zi*zr+ci
  98.  
  99.       r=sr*sr+si*si
  100.       IF r>=4 THEN loopExit
  101.  
  102.       zr=sr
  103.       zi=si
  104.  
  105.     NEXT S
  106.  
  107.   loopExit:
  108.  
  109.     zr=0:zi=0
  110.     x=x+1
  111.     IF x>ScrWidth THEN
  112.       y=y+1
  113.       x=1
  114.       cr=xStart
  115.       ci=ci-yStep
  116.     ELSE
  117.       cr=cr+xStep
  118.     END IF
  119.  
  120.     IF r>=4 THEN PSET(x,y),Betrag(S)
  121.  
  122.   WEND
  123.  
  124. Speichern:
  125.   WINDOW 1
  126.   INPUT "FileName: ",nam$
  127.   IF nam$="" THEN INPUT "FileName: ",nam$
  128.   IF nam$="" THEN sCont
  129.   WINDOW 3
  130.     GOSUB Main
  131.  
  132. sCont:
  133.   WHILE MOUSE(0)=0:WEND
  134.   WHILE MOUSE(0)=-1:WEND  
  135.   BEEP
  136.   WINDOW 3
  137.   WHILE MOUSE(0)=0:WEND
  138.  
  139.     x1=MOUSE(1):y1=MOUSE(2)
  140.  
  141.   WHILE MOUSE(0)=-1:WEND
  142.  
  143.     x2=MOUSE(1):y2=MOUSE(2)
  144.  
  145.     xStart=xStart+x1*xStep
  146.     xEnd=xStart+x2*xStep
  147.     yStart=yStart-y1*yStep
  148.     yEnd=yStart-y2*yStep
  149.  
  150.   Com=1
  151.   ERASE Betrag
  152.   WINDOW 1
  153.  GOTO Parameter
  154.  
  155.  
  156.  
  157. REM - SaveILBM
  158. REM -  von Carolyn Scheppner  CBM  04/86
  159. REM -  Eindeutschung Ki 03.12.86
  160.  
  161. '" - ( s.a. Bitte-lesen, LoadACBM,
  162. '" -   LoadILBM-SaveACBM )
  163.  
  164. '" - Dieses Programm speichert einen
  165. '" - eigenen Bildschirm (Screen), 
  166. '" - der eine Grafik enthält, als 
  167. '" - eine IFF-ILBM-Datei (lesbar von
  168. '" - Graphicraft, Deluxe Paint, etc.).
  169.  
  170. '" - Die Datei erhält kein Piktogramm.
  171. '" - Wenn Sie eins brauchen, kopieren
  172. '" - Sie die .info-Datei eines
  173. '" - Graphicraft-Bildes und benennen
  174. '" - sie um zu   IhreDatei.info   .
  175.  
  176. '" - Daten fr zyklischen Farbwechsel
  177. '" - werden als Graphicraft-CCRT-Chunk
  178. '" - gespeichert. Sie können das Pro-
  179. '" - gramm auch umbauen, so daß die
  180. '" - Farbzyklus-Daten als CRNG-Chunk
  181. '" - wie in dPaint gespeichert werden.
  182. '" - (IFF-Dateien sind in benamte
  183. '" -  Abschnitte, Chunks, gegliedert.)
  184.  
  185. '" - Benötigt werden die .bmap-Dateien
  186. '" - zu  exec, graphics und dos .
  187.  
  188. Main:
  189.  
  190. DIM bPlane&(5), cTabSave%(32)
  191.  
  192. LIBRARY "dos.library"
  193. LIBRARY "exec.library"
  194. LIBRARY "graphics.library"
  195.  
  196. REM - Functionen aus dos.library                   
  197. DECLARE FUNCTION xOpen&  LIBRARY
  198. DECLARE FUNCTION xRead&  LIBRARY
  199. DECLARE FUNCTION xWrite& LIBRARY
  200. REM - xClose returns no value
  201.  
  202. REM - Functionen aus exec.library
  203. DECLARE FUNCTION AllocMem&() LIBRARY
  204. REM - FreeMem returns no value
  205.  
  206.  
  207. ILBMname$=nam$
  208.  
  209. REM  Eigener Screen, etwas Grafik
  210. w = 320: h = 200: d = 5
  211.  
  212. AvailRam& = FRE(-1)
  213. NeededRam& = ((w/8)*h*(d+1))+5000
  214. IF AvailRam& < NeededRam& THEN
  215.    PRINT "Rechner-Speicherplatz reicht nicht aus."
  216.    GOTO Mcleanup2
  217. END IF   
  218.  
  219. t$=" SaveILBM"
  220.  
  221. REM - Screen-Structure-Adressen ermitteln
  222. GOSUB GetScrAddrs
  223.  
  224. '" - Farbzyklusvariablen initialisieren
  225. '" - ( mit 0 fr keinen Zyklus ).
  226. '" - Diese Variablen mssen initialisiert
  227. '" - werden, da diese Version von SaveILBM
  228. '" - immer einen CCRT-Chunk wie fr
  229. '" - Graphicraft abspeichert.
  230. ccrtDir%   = 0
  231. ccrtStart% = 1
  232. ccrtEnd%   = nColors% - 1
  233. ccrtSecs&  = 0
  234. ccrtMics&  = 2000
  235.  
  236.  
  237. REM - Screen als IFF-ILBM-Datei abspeichern
  238. IF (ILBMname$<>"") THEN
  239.    saveError$ = ""
  240.    GOSUB SaveILBM
  241. END IF
  242.  
  243. Mcleanup:
  244. FOR de = 1 TO 5000:NEXT
  245.  
  246. Mcleanup2:
  247. LIBRARY CLOSE
  248. IF saveError$ <> "" THEN PRINT saveError$
  249. RETURN
  250.  
  251.  
  252.  
  253. SaveILBM:
  254. '" - Speichert aktuellen Fensterinhalt
  255. '" - als IFF-ILBM-Datei mit einem
  256. '" - CCRT-Farbzyklus-Chunk wie Graphicraft.
  257. '" - (IFF-Dateien sind in benamte Chunks
  258. '" -  gegliedert.)
  259. '" - Folgende Variablen mssen initiali-
  260. '" - siert sein:
  261. '" -    ILBMname$ (IFF-ILBM-Dateiname)
  262. '" - Und die Farbzyklus-Variablen:
  263. '" -    ccrtDir% (1,-1, oder 0 = kein Zyklus)
  264. '" -    ccrtStart% (niederwertiges Zyklus-Register)
  265. '" -    ccrtEnd%   (höherwertiges  Zyklus-Register)
  266. '" -    ccrtSecs&  (Zykluszeit in Sekunden)
  267. '" -    ccrtMics&  (Zykluszeit in Mikrosekunden) 
  268.  
  269.  
  270. '" - Variablen initialisieren
  271. f$ = ILBMname$
  272. fHandle& = 0
  273. mybuf& = 0
  274.  
  275. filename$ = f$ + CHR$(0)
  276. fHandle& = xOpen&(SADD(filename$),1006)
  277. IF fHandle& = 0 THEN
  278.    saveError$ = "Ausgabedatei nicht erzeugbar."
  279.    GOTO Scleanup
  280. END IF
  281.  
  282. REM - Pufferspeicherplatz reservieren
  283. ClearPublic& = 65537&
  284. mybufsize& = 120
  285. mybuf& = AllocMem&(mybufsize&,ClearPublic&)
  286. IF mybuf& = 0 THEN
  287.    saveError$ = "Pufferspeicher nicht verfgbar."
  288.    GOTO Scleanup
  289. END IF
  290.  
  291. cbuf& = mybuf&
  292.  
  293. REM - Adressen der Screen-Structures ermitteln
  294. GOSUB GetScrAddrs
  295.  
  296. zero& = 0
  297. pad%  = 0
  298. aspect% = &HA0B
  299.  
  300. REM - Chunk-Längen berechnen
  301. BMHDsize& = 20
  302. CMAPsize& = (2^scrDepth%) * 3
  303. CAMGsize& = 4
  304. CCRTsize& = 14
  305. BODYsize& = (ScrWidth%/8) * scrHeight% * scrDepth%
  306. REM - FORMsize& = Chunk-Längen + 8 Bytes je Chunk-Header + "ILBM"
  307. FORMsize& = BMHDsize&+CMAPsize&+CAMGsize&+CCRTsize&+BODYsize&+44
  308.  
  309. REM - FORM-Header schreiben
  310. tt$ = "FORM"
  311. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  312. wLen& = xWrite&(fHandle&,VARPTR(FORMsize&),4)
  313. tt$ = "ILBM"
  314. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  315.  
  316. IF wLen& <= 0 THEN
  317.    saveError$ = "Schreibfehler beim FORM-Header."
  318.    GOTO Scleanup
  319. END IF   
  320.  
  321. REM - BMHD-Chunk schreiben
  322. tt$ = "BMHD"
  323. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  324. wLen& = xWrite&(fHandle&,VARPTR(BMHDsize&),4)
  325. wLen& = xWrite&(fHandle&,VARPTR(ScrWidth%),2)
  326. wLen& = xWrite&(fHandle&,VARPTR(scrHeight%),2)
  327. wLen& = xWrite&(fHandle&,VARPTR(zero&),4)
  328. temp% = (256 * scrDepth%)
  329. wLen& = xWrite&(fHandle&,VARPTR(temp%),2)
  330. wLen& = xWrite&(fHandle&,VARPTR(zero&),4)
  331. wLen& = xWrite&(fHandle&,VARPTR(aspect%),2)
  332. wLen& = xWrite&(fHandle&,VARPTR(ScrWidth%),2)
  333. wLen& = xWrite&(fHandle&,VARPTR(scrHeight%),2)
  334.  
  335. IF wLen& <= 0 THEN
  336.    saveError$ = "Schreibfehler beim BMHD-Chunk."
  337.    GOTO Scleanup
  338. END IF   
  339.  
  340. REM - CMAP-Chunk schreiben
  341. tt$ = "CMAP"
  342. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  343. wLen& = xWrite&(fHandle&,VARPTR(CMAPsize&),4)
  344.  
  345. REM - IFF-Farbpalette aufbauen
  346. FOR kk = 0 TO nColors% - 1
  347.    regTemp% = PEEKW(colorTab& + (2*kk))
  348.    POKE(cbuf&+(kk*3)),(regTemp% AND &HF00) / 16
  349.    POKE(cbuf&+(kk*3)+1),(regTemp% AND &HF0) 
  350.    POKE(cbuf&+(kk*3)+2),(regTemp% AND &HF) * 16
  351. NEXT
  352.  
  353. wLen& = xWrite&(fHandle&,cbuf&,CMAPsize&)
  354.  
  355. IF wLen& <= 0 THEN
  356.    saveError$ = "Schreibfehler beim CMAP-Chunk."
  357.    GOTO Scleanup
  358. END IF   
  359.  
  360. REM - CAMG-Chunk schreiben
  361. tt$ = "CAMG"
  362. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  363. wLen& = xWrite&(fHandle&,VARPTR(CAMGsize&),4)
  364. vpModes& = PEEKW(sViewPort& + 32)
  365. wLen& = xWrite&(fHandle&,VARPTR(vpModes&),4)
  366.  
  367. IF wLen& <= 0 THEN
  368.    saveError$ = "Schreibfehler beim CAMG-Chunk"
  369.    GOTO Scleanup
  370. END IF   
  371.  
  372.  
  373. REM - CCRT-Chunk schreiben
  374. tt$ = "CCRT"
  375. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  376. wLen& = xWrite&(fHandle&,VARPTR(CCRTsize&),4)
  377. wLen& = xWrite&(fHandle&,VARPTR(ccrtDir%),2)
  378. temp% = (256*ccrtStart%) + ccrtEnd%
  379. wLen& = xWrite&(fHandle&,VARPTR(temp%),2)
  380. wLen& = xWrite&(fHandle&,VARPTR(ccrtSecs&),4)
  381. wLen& = xWrite&(fHandle&,VARPTR(ccrtMics&),4)
  382. wLen& = xWrite&(fHandle&,VARPTR(pad%),2)
  383.  
  384. IF wLen& <= 0 THEN
  385.    saveError$ = "Schreibfehler beim CCRT-Chunk."
  386.    GOTO Scleanup
  387. END IF   
  388.  
  389.  
  390. REM - BODY-Chunk schreiben (eigentliche Pixeldaten)
  391. tt$ = "BODY"
  392. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  393. wLen& = xWrite&(fHandle&,VARPTR(BODYsize&),4)
  394.  
  395. scrRowBytes% = ScrWidth% / 8
  396. FOR rr = 0 TO scrHeight% -1
  397.    FOR pp = 0 TO scrDepth% -1
  398.       scrRow& = bPlane&(pp)+(rr*scrRowBytes%)
  399.       wLen& = xWrite&(fHandle&,scrRow&,scrRowBytes%)   
  400.       IF wLen& <= 0 THEN
  401.          saveError$ = "Schreibfehler beim BODY-Chunk."
  402.          GOTO Scleanup
  403.       END IF   
  404.    NEXT
  405. NEXT
  406.  
  407.    
  408. saveError$ = ""
  409.  
  410. Scleanup:
  411. IF fHandle& <> 0 THEN CALL xClose&(fHandle&)
  412. IF mybuf& <> 0 THEN CALL FreeMem&(mybuf&,mybufsize&)
  413. RETURN
  414.  
  415.  
  416.  
  417. GetScrAddrs:
  418. REM - Adressen der Screen-Structures ermitteln
  419.    sWindow&   = WINDOW(7)
  420.    sScreen&   = PEEKL(sWindow& + 46)
  421.    sViewPort& = sScreen& + 44
  422.    sRastPort& = sScreen& + 84
  423.    sColorMap& = PEEKL(sViewPort& + 4)
  424.    colorTab&  = PEEKL(sColorMap& + 4)
  425.    sBitMap&   = PEEKL(sRastPort& + 4)
  426.  
  427.    REM - Screen-Parameter ermitteln
  428.    ScrWidth%  = PEEKW(sScreen& + 12)
  429.    scrHeight% = PEEKW(sScreen& + 14)
  430.    scrDepth%  = PEEK(sBitMap& + 5)
  431.    nColors%   = 2^scrDepth%
  432.  
  433.    REM - Adressen der Bit-Planes ermitteln
  434.    FOR kk = 0 TO scrDepth% - 1
  435.       bPlane&(kk) = PEEKL(sBitMap&+8+(kk*4))
  436.    NEXT
  437. RETURN
  438.  
  439.  
  440.